perm filename PERSP.OL3[CMS,LCS] blob
sn#720330 filedate 1983-07-17 generic text, type T, neo UTF8
00100 C APPLIES PERSPECTIVE TO DRAWING. EDGE OF 'PAPER' MAY BE CURVED.
00200 IMPLICIT INTEGER(X,Y,Z)
00300 COMMON JHALF,F,LB,D,X,Y,DL,HA,HB
00400 DIMENSION X1(800),Y1(800),Z1(800),X6(800)
00500 DIMENSION X2(200),Y2(200),Z2(200),X7(200),Y7(200)
00600 DIMENSION X3(800),Y3(800),X4(200),Y4(200)
00700 1 ,JJ(4000),X5(200),Y5(200)
00800
00900 JHALF=0
01000 1 FORMAT(' TYPE PICTURE NAME '$)
01100 2 FORMAT(' TYPE CURVE NAME '$)
01200 3 FORMAT(' TYPE OUTPUT NAME '$)
01300 6 FORMAT(A5)
01400 7 FORMAT(4I)
01500 8 FORMAT(' TYPE X,Y FOR VANISHING POINT. '$)
01600 9 FORMAT(' TYPE FORESHORTENING FACTOR. '$)
01700 13 FORMAT(6F)
01800 14 FORMAT(6I)
01900 400 FORMAT(' LEFT=',I4,' RT=',I4,' TOP=',I4,' BOT='I4)
02000 401 FORMAT(' TYPE X,Y FOR LOWER LEFT CORNER, X FOR RIGHT CORNER,'/
02100 1' X,Y FOR UPPER LEFT CORNER '$)
02200 C ASSUMES LEVEL BOTTOM FOR 'PIECE OF PAPER'
02300 4 TYPE 1
02400 ACCEPT 6,NM1
02500 TYPE 2
02600 ACCEPT 6,NM2
02700 XL=9999
02800 XR=-XL
02900 YT=XR
03000 YB=XL
03100 20 REWIND 1
03200 REWIND 20
03300 CALL IFILE(1,NM1)
03400 CALL IFILE(20,NM2)
03500 DO 30 KT=1,800
03600 READ(1,7,END=21)LT,X1(KT),Y1(KT),Z1(KT)
03700 X=X1(KT)
03800 Y=Y1(KT)
03900 IF(X.LT.XL)XL=X
04000 IF(X.GT.XR)XR=X
04100 IF(Y.LT.YB)YB=Y
04200 30 IF(Y.GT.YT)YT=Y
04300 C FIND OUTER DIMENSIONS OF PICTURE
04400 21 KT=KT-1
04500 C NOW KT = TOTAL VECTORS
04600 J=X2(1)
04700 JB=J
04800 TYPE 400,XL,XR,YT,YB
04900 LB=Y2(1)
05000 LT=L
05100 DO 40 K=1,800
05200 READ(20,7,END=22)LT,X2(K),Y2(K),Z2(K)
05300 N=X2(K)
05400 IF(N.LT.J)J=N
05500 IF(N.GT.JB)JB=N
05600 C ASSUMES BASE LINE IS LEVEL FOR NOW
05700 N=Y2(K)
05800 IF(N.LT.LB)LB=N
05900 40 IF(N.GT.LT)LT=N
06000 C GETS TOP AND BOT. LT,LB
06100 22 K=K-1
06200 CC IF(LB.GE.0)GO TO 200
06300 CC DO 201 J=1,K
06400 CC201 Y2(J)=Y2(J)-LB
06500 CC DO 202 J=1,KT
06600 CC202 Y1(J)=Y1(J)-LB
06700 C SHIFT ALL TO Y POSITIVE IF ANY NEG POINTS
06800 200 CALL DPYSET(1,JJ,4000)
06900 CALL DRWIT(X2,Y2,Z2,K)
07000 CALL DRWIT(X1,Y1,Z1,KT)
07100 23 FORMAT(' HORIZONTAL POINTS ARE ',2I4)
07200 24 FORMAT(' VERTICAL POINTS ARE ',2I4)
07300 C TYPE 23,J,JB
07400 C TYPE 24,LB,LT
07500 C ASSUMES TOP AND BOT OF CURVE ARE AT X=0, BOT AT Y=0.
07600 TYPE 401
07700 ACCEPT 14,XL,YB,XR,XL2,YT
07800 FA=LT-LB
07900 C HEIGHT OF CURVE (LB SHOULD BE 0)
08000 FB=YT-YB
08100 C HEIGHT OF 'PIECE OF PAPER' (YB SHOULD BE 0)
08200 G=FB/FA
08300 C FACTOR FOR SIZE DIFFERENCE BETWEEN PAPER AND CURVE
08400 LT=LT*G+.5
08500 LB=LB*G+.5
08600 XL=XH*G+.5
08700 XR=XR*G+.5
08800 YT=YT*G+.5
08900 YB=YB*G+.5
09000 * SCALE EVERYTHING DOWN
09100 FC=XL2-XL
09200 C OFFSET TO TOP OF SLANTED 'PIECE OF PAPER'
09300 25 DO 15 J=1,K
09400 PC=(Y2(J)-LB)/FA
09500 C % OF WAY UP FROM BOT.
09600 Y7(J)=G*Y2(J)+.5
09700 C EXPAND Y TO FIT PAPER
09800 Y4(J)=Y7(J)
09900 X7(J)=X2(J)*G+FC*PC+.5
10000 C EXPAND X BY SAME FACTOR AND TILT IF NECESSARY
10100 15 X4(J)=X7(J)+XR
10200 C SET UP RIGHT SIDE OF PIECE OF PAPER
10300 CALL DRWIT(X7,Y7,Z2,K)
10400 CALL DRWIT(X4,Y4,Z2,K)
10500 C NOW BEND DRAWING TO FIT GIVEN CURVE
10600 J=1
10700 500 S=X1(J)
10800 T=Y1(J)
10900 DO 501 L=1,K-1
11000 C ASSUMES CURVE GOES BELOW AND ABOVE PICTURE
11100 R=Y7(L)
11200 RR=Y7(L+1)
11300 IF(T.LT.R.OR.T.GT.RR)GO TO 501
11400 C H=X7(L)-X7(L+1)
11500 HA=X7(L)
11600 H=X7(L+1)-HA
11700 C G=(R-T)/(Y2(L+1)-T)
11800 G=(R-T)/(R-Y7(L+1))
11900 C G=% OF WAY BETWEEN POINTS
12000 X6(J)=HA+S+H*G+.5
12100 J=J+1
12200 IF(J.LE.KT)GO TO 500
12300 GO TO 502
12400 501 CONTINUE
12500 502 CALL DRWIT(X6,Y1,Z1,KT)
12600 TYPE 8
12700 ACCEPT 7,X,Y
12800 CALL AIVECT(X7(K)-100,Y7(K))
12900 CALL AVECT(X-100,Y)
13000 CALL AVECT(X7(1)-100,Y7(1))
13100 CALL DPYOUT(1)
13200 C SHOWS VANISHING POINT
13300 TYPE 9
13400 ACCEPT 13,F
13500 HA=Y7(K)-Y
13600 C HEIGHT FROM VP TO TOP OF RECT.
13700 HB=Y7(1)-Y
13800 C HEIGHT FROM VP TO BOT OF RECT.
13900 DL=X-X7(1)
14000 C LENGTH FROM LEFT EDGE OF RECT. TO VP
14100 M1=1
14200 C GET FIRST POINTS
14300 C G,LT=TOP OF RECT. H,LB=BOT OF RECT.
14400 G=LT
14500 H=LB
14600 D=G-H
14700 C D=HEIGHT OF RECT.
14720 DO 31 J=1,K
14760 31 CALL FORSH(X7(J),Y7(J),X7(J),Y7(J))
14800 27 DO 26 J=1,K
14900 26 CALL FORSH(X4(J),Y4(J),X5(J),Y5(J))
15000 CALL DRWIT(X5,Y5,Z2,K)
15100 28 DO 10 M1=1,KT
15200 10 CALL FORSH(X6(M1),Y1(M1),X3(M1),Y3(M1))
15300 12 CALL DRWIT(X3,Y3,Z1,KT)
15400 300 FORMAT(' WRITE FILE? '$)
15500 TYPE 300
15600 ACCEPT 6,J
15700 IF(J.NE.'Y')GO TO 301
15800 TYPE 3
15900 ACCEPT 6,J
16000 CALL OFILE(21,J)
16100 IF(JHALF.NE.0)GO TO 304
16200 DO 302 J=1,KT
16300 302 WRITE(21,7)J,X3(J),Y3(J),Z1(J)
16400 C WRITES FILE TO BE USED WITH 'RE' IN THE DRW PROGRAM.
16500 J=KT
16600 DO 306 JK=1,K
16700 J=J+1
16800 306 WRITE(21,7)J,X5(JK),Y5(JK),Z2(JK)
16900 DO 307 JK=1,K
17000 J=J+1
17100 307 WRITE(21,7)J,X7(JK),Y7(JK),Z2(JK)
17200 J=J+1
17300 JK=1
17400 WRITE(21,7)J,X5(1),Y5(1),JK
17500 J=J+1
17600 JL=0
17700 WRITE(21,7)J,X7(1),Y7(1),JL
17800 J=J+1
17900 WRITE(21,7)J,X5(K),Y5(K),JK
18000 J=J+1
18100 WRITE(21,7)J,X7(K),Y7(K),JL
18200 303 JHALF=0
18300 END FILE 21
18400 301 CALL HYDPOG(1)
18500 GO TO 200
18600 304 DO 305 J=1,KT
18700 C HALF SIZE IF X OR Y .GE.1000
18800 LX=X3(J)/2
18900 LY=Y3(J)/2
19000 305 WRITE(21,7)J,LX,LY,Z1(J)
19100 GO TO 303
19200 END
19300
19400 SUBROUTINE DRWIT(X,Y,Z,K)
19500 INTEGER X,Y,Z
19600 DIMENSION X(1),Y(1),Z(1)
19700 DO 1 J=1,K
19800 IF(Z(J).EQ.0)GO TO 2
19900 CALL AIVECT(X(J)-100,Y(J))
20000 GO TO 1
20100 2 CALL AVECT(X(J)-100,Y(J))
20200 1 CONTINUE
20300 CALL DPYOUT(1)
20400 END
20500
20600 SUBROUTINE FORSH(XA,YA,XB,YB)
20700 IMPLICIT INTEGER (X,Y)
20800 COMMON JHALF,F,LB,D,X,Y,DL,HA,HB
21000 C D=HEIGHT OF 'PIECE OF PAPER', DL=DIST. FROM LEFT EDGE TO VP.
21200 A=1.0-XA/DL
21220 C X SHIFT FACTOR
21240 B=A*HA+Y
21260 C UPPER Y INTERSECTION
21280 C=A*HB+Y
21300 C LOWER Y INTERSECTION
21320 1 FACX=F*(B-C)/D
21340 C % OF THIS VERTICAL SEG. TO SEG. AT POSITION 0
21350 C F IS FORSHORTENING FACTOR
21360 XB=XA*FACX+.5
21380 C SET NEW X VALUE FOR THIS POINT
21400 2 A=1.0-XB/DL
21420 C NOW GET VERTICAL SEG. FOR ALTERED X VALUE
21440 B=A*HA+Y
21460 C=A*HB+Y
21480 3 FAC=(B-C)/D
21500 C FACTOR FOR Y VALUE
21520 YB=YA*FAC+C+.5
22200 4 IF(IABS(YB).GE.1000)JHALF=-1
22600 IF(IABS(XB).GE.1000)JHALF=-1
22900 END